home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / format.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  43.3 KB  |  2,136 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     format.c
  24. */
  25.  
  26. #include "include.h"
  27. #include <varargs.h>
  28. object siVindent_formatted_output;
  29.  
  30. object fmt_stream;
  31. int ctl_origin;
  32. int ctl_index;
  33. int ctl_end;
  34. object *fmt_base;
  35. int fmt_index;
  36. int fmt_end;
  37. int *fmt_jmp_buf;
  38. int fmt_indents;
  39. object fmt_string;
  40.  
  41. #define    ctl_string    (fmt_string->st.st_self + ctl_origin)
  42.  
  43. #define    fmt_old        VOL object old_fmt_stream; \
  44.             VOL int old_ctl_origin; \
  45.             VOL int old_ctl_index; \
  46.             VOL int old_ctl_end; \
  47.             object * VOL old_fmt_base; \
  48.             VOL int old_fmt_index; \
  49.             VOL int old_fmt_end; \
  50.             int  * VOL old_fmt_jmp_buf; \
  51.             VOL int old_fmt_indents; \
  52.             VOL object old_fmt_string
  53. #define    fmt_save    old_fmt_stream = fmt_stream; \
  54.             old_ctl_origin = ctl_origin; \
  55.             old_ctl_index = ctl_index; \
  56.             old_ctl_end = ctl_end; \
  57.             old_fmt_base = fmt_base; \
  58.             old_fmt_index = fmt_index; \
  59.             old_fmt_end = fmt_end; \
  60.             old_fmt_jmp_buf = fmt_jmp_buf; \
  61.             old_fmt_indents = fmt_indents; \
  62.             old_fmt_string = fmt_string
  63. #define    fmt_restore    fmt_stream = old_fmt_stream; \
  64.             ctl_origin = old_ctl_origin; \
  65.             ctl_index = old_ctl_index; \
  66.             ctl_end = old_ctl_end; \
  67.             fmt_base = old_fmt_base; \
  68.             fmt_index = old_fmt_index; \
  69.             fmt_end = old_fmt_end; \
  70.             fmt_jmp_buf = old_fmt_jmp_buf; \
  71.             fmt_indents = old_fmt_indents; \
  72.             fmt_string = old_fmt_string
  73. #define    fmt_restore1    fmt_stream = old_fmt_stream; \
  74.             ctl_origin = old_ctl_origin; \
  75.             ctl_index = old_ctl_index; \
  76.             ctl_end = old_ctl_end; \
  77.             fmt_jmp_buf = old_fmt_jmp_buf; \
  78.             fmt_indents = old_fmt_indents; \
  79.             fmt_string = old_fmt_string
  80.  
  81. #ifndef WRITEC_NEWLINE
  82. #define  WRITEC_NEWLINE(strm) (writec_stream('\n',strm))
  83. #endif
  84.  
  85. object fmt_temporary_stream;
  86. object fmt_temporary_string;
  87.  
  88. int fmt_nparam;
  89. #define    INT    1
  90. #define    CHAR    2
  91. struct {
  92.     int fmt_param_type;
  93.     int fmt_param_value;
  94. } fmt_param[100];
  95.  
  96.  
  97. char *fmt_big_numeral[] = {
  98.     "thousand",
  99.     "million",
  100.     "billion",
  101.     "trillion",
  102.     "quadrillion",
  103.     "quintillion",
  104.     "sextillion",
  105.     "septillion",
  106.     "octillion"
  107. };
  108.  
  109. char *fmt_numeral[] = {
  110.     "zero", "one", "two", "three", "four",
  111.     "five", "six", "seven", "eight", "nine",
  112.     "ten", "eleven", "twelve", "thirteen", "fourteen",
  113.     "fifteen", "sixteen", "seventeen", "eighteen", "nineteen",
  114.     "zero", "ten", "twenty", "thirty", "forty",
  115.     "fifty", "sixty", "seventy", "eighty", "ninety"
  116. };
  117.  
  118. char *fmt_ordinal[] = {
  119.     "zeroth", "first", "second", "third", "fourth",
  120.     "fifth", "sixth", "seventh", "eighth", "ninth",
  121.     "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth",
  122.     "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth",
  123.     "zeroth", "tenth", "twentieth", "thirtieth", "fortieth",
  124.     "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth"
  125. };
  126.  
  127.  
  128. int fmt_spare_spaces;
  129. int fmt_line_length;
  130.  
  131.  
  132. int
  133. fmt_tempstr(s)
  134. int s;
  135. {
  136.     return(fmt_temporary_string->st.st_self[s]);
  137. }
  138.  
  139. ctl_advance()
  140. {
  141.     if (ctl_index >= ctl_end)
  142.         fmt_error("unexpected end of control string");
  143.     return(ctl_string[ctl_index++]);
  144. }
  145.  
  146. object
  147. fmt_advance()
  148. {
  149.     if (fmt_index >= fmt_end)
  150.         fmt_error("arguments exhausted");
  151.     return(fmt_base[fmt_index++]);
  152. }
  153.  
  154.  
  155. format(fmt_stream0, ctl_origin0, ctl_end0)
  156. object fmt_stream0;
  157. int ctl_origin0;
  158. int ctl_end0;
  159. {
  160.     int c, i, n;
  161.     bool colon, atsign;
  162.     object x;
  163.  
  164.     fmt_stream = fmt_stream0;
  165.     ctl_origin = ctl_origin0;
  166.     ctl_index = 0;
  167.     ctl_end = ctl_end0;
  168.  
  169. LOOP:
  170.     if (ctl_index >= ctl_end)
  171.         return;
  172.     if ((c = ctl_advance()) != '~') {
  173.         writec_stream(c, fmt_stream);
  174.         goto LOOP;
  175.     }
  176.     n = 0;
  177.     for (;;) {
  178.         switch (c = ctl_advance()) {
  179.         case ',':
  180.             fmt_param[n].fmt_param_type = NULL;
  181.             break;
  182.  
  183.         case '0':  case '1':  case '2':  case '3':  case '4':
  184.         case '5':  case '6':  case '7':  case '8':  case '9':
  185.         DIGIT:
  186.             i = 0;
  187.             do {
  188.                 i = i*10 + (c - '0');
  189.                 c = ctl_advance();
  190.             } while (isDigit(c));
  191.             fmt_param[n].fmt_param_type = INT;
  192.             fmt_param[n].fmt_param_value = i;
  193.             break;
  194.  
  195.         case '+':
  196.             c = ctl_advance();
  197.             if (!isDigit(c))
  198.                 fmt_error("digit expected");
  199.             goto DIGIT;
  200.  
  201.         case '-':
  202.             c = ctl_advance();
  203.             if (!isDigit(c))
  204.                 fmt_error("digit expected");
  205.             i = 0;
  206.             do {
  207.                 i = i*10 + (c - '0');
  208.                 c = ctl_advance();
  209.             } while (isDigit(c));
  210.             fmt_param[n].fmt_param_type = INT;
  211.             fmt_param[n].fmt_param_value = -i;
  212.             break;
  213.  
  214.         case '\'':
  215.             fmt_param[n].fmt_param_type = CHAR;
  216.             fmt_param[n].fmt_param_value = ctl_advance();
  217.             c = ctl_advance();
  218.             break;
  219.  
  220.         case 'v':  case 'V':
  221.             x = fmt_advance();
  222.             if (type_of(x) == t_fixnum) {
  223.                 fmt_param[n].fmt_param_type = INT;
  224.                 fmt_param[n].fmt_param_value = fix(x);
  225.             } else if (type_of(x) == t_character) {
  226.                 fmt_param[n].fmt_param_type = CHAR;
  227.                 fmt_param[n].fmt_param_value = x->ch.ch_code;
  228.                         } else if (x == Cnil) {
  229.                                  fmt_param[n].fmt_param_type = NULL;                
  230.             } else
  231.                 fmt_error("illegal V parameter");
  232.             c = ctl_advance();
  233.             break;
  234.  
  235.         case '#':
  236.             fmt_param[n].fmt_param_type = INT;
  237.             fmt_param[n].fmt_param_value = fmt_end - fmt_index;
  238.             c = ctl_advance();
  239.             break;
  240.  
  241.         default:
  242.             if (n > 0)
  243.                 fmt_error("illegal ,");
  244.             else
  245.                 goto DIRECTIVE;
  246.         }
  247.         n++;
  248.         if (c != ',')
  249.             break;
  250.     }
  251.  
  252. DIRECTIVE:
  253.     colon = atsign = FALSE;
  254.     if (c == ':') {
  255.         colon = TRUE;
  256.         c = ctl_advance();
  257.     }
  258.     if (c == '@') {
  259.         atsign = TRUE;
  260.         c = ctl_advance();
  261.     }
  262.     fmt_nparam = n;
  263.     switch (c) {
  264.     case 'a':  case 'A':
  265.         fmt_ascii(colon, atsign);
  266.         break;
  267.  
  268.     case 's':  case 'S':
  269.         fmt_S_expression(colon, atsign);
  270.         break;
  271.  
  272.     case 'd':  case 'D':
  273.         fmt_decimal(colon, atsign);
  274.         break;
  275.  
  276.     case 'b':  case 'B':
  277.         fmt_binary(colon, atsign);
  278.         break;
  279.  
  280.     case 'o':  case 'O':
  281.         fmt_octal(colon, atsign);
  282.         break;
  283.  
  284.     case 'x':  case 'X':
  285.         fmt_hexadecimal(colon, atsign);
  286.         break;
  287.  
  288.     case 'r':  case 'R':
  289.         fmt_radix(colon, atsign);
  290.         break;
  291.  
  292.     case 'p':  case 'P':
  293.         fmt_plural(colon, atsign);
  294.         break;
  295.  
  296.     case 'c':  case 'C':
  297.         fmt_character(colon, atsign);
  298.         break;
  299.  
  300.     case 'f':  case 'F':
  301.         fmt_fix_float(colon, atsign);
  302.         break;
  303.  
  304.     case 'e':  case 'E':
  305.         fmt_exponential_float(colon, atsign);
  306.         break;
  307.  
  308.     case 'g':  case 'G':
  309.         fmt_general_float(colon, atsign);
  310.         break;
  311.  
  312.     case '$':
  313.         fmt_dollars_float(colon, atsign);
  314.         break;
  315.  
  316.     case '%':
  317.         fmt_percent(colon, atsign);
  318.         break;
  319.  
  320.     case '&':
  321.         fmt_ampersand(colon, atsign);
  322.         break;
  323.  
  324.     case '|':
  325.         fmt_bar(colon, atsign);
  326.         break;
  327.  
  328.     case '~':
  329.         fmt_tilde(colon, atsign);
  330.         break;
  331.  
  332.     case '\n':
  333.     case '\r':    
  334.         fmt_newline(colon, atsign);
  335.         break;
  336.  
  337.     case 't':  case 'T':
  338.         fmt_tabulate(colon, atsign);
  339.         break;
  340.  
  341.     case '*':
  342.         fmt_asterisk(colon, atsign);
  343.         break;
  344.  
  345.     case '?':
  346.         fmt_indirection(colon, atsign);
  347.         break;
  348.  
  349.     case '(':
  350.         fmt_case(colon, atsign);
  351.         break;
  352.  
  353.     case '[':
  354.         fmt_conditional(colon, atsign);
  355.         break;
  356.  
  357.     case '{':
  358.         fmt_iteration(colon, atsign);
  359.         break;
  360.  
  361.     case '<':
  362.         fmt_justification(colon, atsign);
  363.         break;
  364.  
  365.     case '^':
  366.         fmt_up_and_out(colon, atsign);
  367.         break;
  368.  
  369.     case ';':
  370.         fmt_semicolon(colon, atsign);
  371.         break;
  372.  
  373.     default:
  374.    {object user_fmt=getf(siVindent_formatted_output->s.s_plist,make_fixnum(c),Cnil);
  375.     
  376.     if (user_fmt!=Cnil)
  377.      {object *oldbase=vs_base;
  378.       object *oldtop=vs_top;
  379.       vs_base=vs_top;
  380.       vs_push(fmt_advance());
  381.       vs_push(fmt_stream);
  382.       vs_push(make_fixnum(colon));
  383.       vs_push(make_fixnum(atsign));
  384.       if (type_of(user_fmt)==t_symbol) user_fmt=symbol_function(user_fmt);
  385.       funcall(user_fmt);
  386.       vs_base=oldbase; vs_top=oldtop; break;}}
  387.         fmt_error("illegal directive");
  388.     }
  389.     goto LOOP;
  390. }
  391.  
  392.  
  393.  
  394. fmt_skip()
  395. {
  396.     int c, level = 0;
  397.     
  398. LOOP:
  399.     if (ctl_advance() != '~')
  400.         goto LOOP;
  401.     for (;;)
  402.         switch (c = ctl_advance()) {
  403.         case '\'':
  404.             ctl_advance();
  405.  
  406.         case ',':
  407.         case '0':  case '1':  case '2':  case '3':  case '4':
  408.         case '5':  case '6':  case '7':  case '8':  case '9':
  409.         case '+':
  410.         case '-':
  411.         case 'v':  case 'V':
  412.         case '#':
  413.         case ':':  case '@':
  414.             continue;
  415.  
  416.         default:
  417.             goto DIRECTIVE;
  418.         }
  419.  
  420. DIRECTIVE:
  421.     switch (c) {
  422.     case '(':  case '[':  case '<':  case '{':
  423.         level++;
  424.         break;
  425.  
  426.     case ')':  case ']':  case '>':  case '}':
  427.         if (level == 0)
  428.             return(ctl_index);
  429.         else
  430.             --level;
  431.         break;
  432.  
  433.     case ';':
  434.         if (level == 0)
  435.             return(ctl_index);
  436.         break;
  437.     }
  438.     goto LOOP;
  439. }
  440.  
  441.  
  442. fmt_max_param(n)
  443. {
  444.     if (fmt_nparam > n)
  445.         fmt_error("too many parameters");
  446. }
  447.  
  448. fmt_not_colon(colon)
  449. bool colon;
  450. {
  451.     if (colon)
  452.         fmt_error("illegal :");
  453. }
  454.  
  455. fmt_not_atsign(atsign)
  456. bool atsign;
  457. {
  458.     if (atsign)
  459.         fmt_error("illegal @");
  460. }
  461.  
  462. fmt_not_colon_atsign(colon, atsign)
  463. bool colon, atsign;
  464. {
  465.     if (colon && atsign)
  466.         fmt_error("illegal :@");
  467. }
  468.  
  469. fmt_set_param(i, p, t, v)
  470. int i, *p, t, v;
  471. {
  472.     if (i >= fmt_nparam || fmt_param[i].fmt_param_type == NULL)
  473.         *p = v;
  474.     else if (fmt_param[i].fmt_param_type != t)
  475.         fmt_error("illegal parameter type");
  476.     else
  477.         *p = fmt_param[i].fmt_param_value;
  478. }    
  479.  
  480.  
  481. fmt_ascii(colon, atsign)
  482. {
  483.     int mincol, colinc, minpad, padchar;
  484.     object x;
  485.     int c, l, i;
  486.  
  487.     fmt_max_param(4);
  488.     fmt_set_param(0, &mincol, INT, 0);
  489.     fmt_set_param(1, &colinc, INT, 1);
  490.     fmt_set_param(2, &minpad, INT, 0);
  491.     fmt_set_param(3, &padchar, CHAR, ' ');
  492.  
  493.     fmt_temporary_string->st.st_fillp = 0;
  494.     fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream);
  495.     fmt_temporary_stream->sm.sm_int1 = file_column(fmt_stream);
  496.     x = fmt_advance();
  497.     if (colon && x == Cnil)
  498.         writestr_stream("()", fmt_temporary_stream);
  499.     else if (mincol == 0 && minpad == 0) {
  500.         princ(x, fmt_stream);
  501.         return;
  502.     } else
  503.         princ(x, fmt_temporary_stream);
  504.     l = fmt_temporary_string->st.st_fillp;
  505.     for (i = minpad;  l + i < mincol;  i += colinc)
  506.         ;
  507.     if (!atsign) {
  508.         write_string(fmt_temporary_string, fmt_stream);
  509.         while (i-- > 0)
  510.             writec_stream(padchar, fmt_stream);
  511.     } else {
  512.         while (i-- > 0)
  513.             writec_stream(padchar, fmt_stream);
  514.         write_string(fmt_temporary_string, fmt_stream);
  515.     }
  516. }
  517.  
  518. fmt_S_expression(colon, atsign)
  519. {
  520.     int mincol, colinc, minpad, padchar;
  521.     object x;
  522.     int c, l, i;
  523.  
  524.     fmt_max_param(4);
  525.     fmt_set_param(0, &mincol, INT, 0);
  526.     fmt_set_param(1, &colinc, INT, 1);
  527.     fmt_set_param(2, &minpad, INT, 0);
  528.     fmt_set_param(3, &padchar, CHAR, ' ');
  529.  
  530.     fmt_temporary_string->st.st_fillp = 0;
  531.     fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream);
  532.     fmt_temporary_stream->sm.sm_int1 = file_column(fmt_stream);
  533.     x = fmt_advance();
  534.     if (colon && x == Cnil)
  535.         writestr_stream("()", fmt_temporary_stream);
  536.     else if (mincol == 0 && minpad == 0) {
  537.         prin1(x, fmt_stream);
  538.         return;
  539.     } else
  540.         prin1(x, fmt_temporary_stream);
  541.     l = fmt_temporary_string->st.st_fillp;
  542.     for (i = minpad;  l + i < mincol;  i += colinc)
  543.         ;
  544.     if (!atsign) {
  545.         write_string(fmt_temporary_string, fmt_stream);
  546.         while (i-- > 0)
  547.             writec_stream(padchar, fmt_stream);
  548.     } else {
  549.         while (i-- > 0)
  550.             writec_stream(padchar, fmt_stream);
  551.         write_string(fmt_temporary_string, fmt_stream);
  552.     }
  553. }
  554.  
  555. fmt_decimal(colon, atsign)
  556. {
  557.     int mincol, padchar, commachar;
  558.  
  559.     fmt_max_param(3);
  560.     fmt_set_param(0, &mincol, INT, 0);
  561.     fmt_set_param(1, &padchar, CHAR, ' ');
  562.     fmt_set_param(2, &commachar, CHAR, ',');
  563.     fmt_integer(fmt_advance(), colon, atsign,
  564.             10, mincol, padchar, commachar);
  565. }
  566.  
  567. fmt_binary(colon, atsign)
  568. {
  569.     int mincol, padchar, commachar;
  570.  
  571.     fmt_max_param(3);
  572.     fmt_set_param(0, &mincol, INT, 0);
  573.     fmt_set_param(1, &padchar, CHAR, ' ');
  574.     fmt_set_param(2, &commachar, CHAR, ',');
  575.     fmt_integer(fmt_advance(), colon, atsign,
  576.             2, mincol, padchar, commachar);
  577. }
  578.  
  579. fmt_octal(colon, atsign)
  580. {
  581.     int mincol, padchar, commachar;
  582.  
  583.     fmt_max_param(3);
  584.     fmt_set_param(0, &mincol, INT, 0);
  585.     fmt_set_param(1, &padchar, CHAR, ' ');
  586.     fmt_set_param(2, &commachar, CHAR, ',');
  587.     fmt_integer(fmt_advance(), colon, atsign,
  588.             8, mincol, padchar, commachar);
  589. }
  590.  
  591. fmt_hexadecimal(colon, atsign)
  592. {
  593.     int mincol, padchar, commachar;
  594.  
  595.     fmt_max_param(3);
  596.     fmt_set_param(0, &mincol, INT, 0);
  597.     fmt_set_param(1, &padchar, CHAR, ' ');
  598.     fmt_set_param(2, &commachar, CHAR, ',');
  599.     fmt_integer(fmt_advance(), colon, atsign,
  600.             16, mincol, padchar, commachar);
  601. }
  602.  
  603. fmt_radix(colon, atsign)
  604. {
  605.     int radix, mincol, padchar, commachar;
  606.     object x;
  607.     int i, j, k;
  608.     int s, t;
  609.     bool b;
  610.     extern (*write_ch_fun)(), writec_PRINTstream();
  611.  
  612.     if (fmt_nparam == 0) {
  613.         x = fmt_advance();
  614.         check_type_integer(&x);
  615.         if (atsign) {
  616.             if (type_of(x) == t_fixnum)
  617.                 i = fix(x);
  618.             else
  619.                 i = -1;
  620.             if (!colon && (i <= 0 || i >= 4000) ||
  621.                 colon && (i <= 0 || i >= 5000)) {
  622.                 fmt_integer(x, FALSE, FALSE, 10, 0, ' ', ',');
  623.                 return;
  624.             }
  625.             fmt_roman(i/1000, 'M', '*', '*', colon);
  626.             fmt_roman(i%1000/100, 'C', 'D', 'M', colon);
  627.             fmt_roman(i%100/10, 'X', 'L', 'C', colon);
  628.             fmt_roman(i%10, 'I', 'V', 'X', colon);
  629.             return;
  630.         }
  631.         fmt_temporary_string->st.st_fillp = 0;
  632.         fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream);
  633.         fmt_temporary_stream->sm.sm_int1 = file_column(fmt_stream);
  634.         PRINTstream = fmt_temporary_stream;
  635.         PRINTradix = FALSE;
  636.         PRINTbase = 10;
  637.         write_ch_fun = writec_PRINTstream;
  638.         write_object(x, 0);
  639.         s = 0;
  640.         i = fmt_temporary_string->st.st_fillp;
  641.         if (i == 1 && fmt_tempstr(s) == '0') {
  642.             writestr_stream("zero", fmt_stream);
  643.             if (colon)
  644.                 writestr_stream("th", fmt_stream);
  645.             return;
  646.         } else if (fmt_tempstr(s) == '-') {
  647.             writestr_stream("minus ", fmt_stream);
  648.             --i;
  649.             s++;
  650.         }
  651.         t = fmt_temporary_string->st.st_fillp;
  652.         for (;;)
  653.             if (fmt_tempstr(--t) != '0')
  654.                 break;
  655.         for (b = FALSE;  i > 0;  i -= j) {
  656.             b = fmt_nonillion(s, j = (i+29)%30+1, b,
  657.                       i<=30&&colon, t);
  658.             s += j;
  659.             if (b && i > 30) {
  660.                 for (k = (i - 1)/30;  k > 0;  --k)
  661.                     writestr_stream(" nonillion",
  662.                             fmt_stream);
  663.                 if (colon && s > t)
  664.                     writestr_stream("th", fmt_stream);
  665.             }
  666.         }
  667.         return;
  668.     }
  669.     fmt_max_param(4);
  670.     fmt_set_param(0, &radix, INT, 10);
  671.     fmt_set_param(1, &mincol, INT, 0);
  672.     fmt_set_param(2, &padchar, CHAR, ' ');
  673.     fmt_set_param(3, &commachar, CHAR, ',');
  674.     x = fmt_advance();
  675.     check_type_integer(&x);
  676.     if (radix < 0 || radix > 36) {
  677.         vs_push(make_fixnum(radix));
  678.         FEerror("~D is illegal as a radix.", 1, vs_head);
  679.     }
  680.     fmt_integer(x, colon, atsign, radix, mincol, padchar, commachar);
  681. }    
  682.  
  683. fmt_integer(x, colon, atsign, radix, mincol, padchar, commachar)
  684. object x;
  685. {
  686.     int l, l1;
  687.     int s;
  688.     extern (*write_ch_fun)(), writec_PRINTstream();
  689.  
  690.     if (type_of(x) != t_fixnum && type_of(x) != t_bignum) {
  691.         fmt_temporary_string->st.st_fillp = 0;
  692.         fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream);
  693.         fmt_temporary_stream->sm.sm_int1 = file_column(fmt_stream);
  694.         setupPRINTdefault(x);
  695.         PRINTstream = fmt_temporary_stream;
  696.         PRINTescape = FALSE;
  697.         PRINTbase = radix;
  698.         write_ch_fun = writec_PRINTstream;
  699.         write_object(x, 0);
  700.         cleanupPRINT();
  701.         l = fmt_temporary_string->st.st_fillp;
  702.         mincol -= l;
  703.         while (mincol-- > 0)
  704.             writec_stream(padchar, fmt_stream);
  705.         for (s = 0;  l > 0;  --l, s++)
  706.             writec_stream(fmt_tempstr(s), fmt_stream);
  707.         return;
  708.     }
  709.     fmt_temporary_string->st.st_fillp = 0;
  710.     fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream);
  711.     fmt_temporary_stream->sm.sm_int1 = file_column(fmt_stream);
  712.     PRINTstream = fmt_temporary_stream;
  713.     PRINTradix = FALSE;
  714.     PRINTbase = radix;
  715.     write_ch_fun = writec_PRINTstream;
  716.     write_object(x, 0);
  717.     l = l1 = fmt_temporary_string->st.st_fillp;
  718.     s = 0;
  719.     if (fmt_tempstr(s) == '-')
  720.         --l1;
  721.     mincol -= l;
  722.     if (colon)
  723.         mincol -= (l1 - 1)/3;
  724.     if (atsign && fmt_tempstr(s) != '-')
  725.         --mincol;
  726.     while (mincol-- > 0)
  727.         writec_stream(padchar, fmt_stream);
  728.     if (fmt_tempstr(s) == '-') {
  729.         s++;
  730.         writec_stream('-', fmt_stream);
  731.     } else if (atsign)
  732.         writec_stream('+', fmt_stream);
  733.     while (l1-- > 0) {
  734.         writec_stream(fmt_tempstr(s++), fmt_stream);
  735.         if (colon && l1 > 0 && l1%3 == 0)
  736.             writec_stream(commachar, fmt_stream);
  737.     }
  738. }
  739.  
  740. fmt_nonillion(s, i, b, o, t)
  741. int s, t;
  742. int i;
  743. bool b, o;
  744. {
  745.     int j;
  746.  
  747.     for (;  i > 3;  i -= j) {
  748.         b = fmt_thousand(s, j = (i+2)%3+1, b, FALSE, t);
  749.         if (j != 3 || fmt_tempstr(s) != '0' ||
  750.             fmt_tempstr(s+1) != '0' || fmt_tempstr(s+2) != '0') {
  751.             writec_stream(' ', fmt_stream);
  752.             writestr_stream(fmt_big_numeral[(i - 1)/3 - 1],
  753.                     fmt_stream);
  754.             s += j;
  755.             if (o && s > t)
  756.                 writestr_stream("th", fmt_stream);
  757.         } else
  758.             s += j;
  759.     }
  760.     return(fmt_thousand(s, i, b, o, t));
  761. }        
  762.  
  763. fmt_thousand(s, i, b, o, t)
  764. int s, t;
  765. int i;
  766. bool b, o;
  767. {
  768.     if (i == 3 && fmt_tempstr(s) > '0') {
  769.         if (b)
  770.             writec_stream(' ', fmt_stream);
  771.         fmt_write_numeral(s, 0);
  772.         writestr_stream(" hundred", fmt_stream);
  773.         --i;
  774.         s++;
  775.         b = TRUE;
  776.         if (o & s > t)
  777.             writestr_stream("th", fmt_stream);
  778.     }
  779.     if (i == 3) {
  780.         --i;
  781.         s++;
  782.     }
  783.     if (i == 2 && fmt_tempstr(s) > '0') {
  784.         if (b)
  785.             writec_stream(' ', fmt_stream);
  786.         if (fmt_tempstr(s) == '1') {
  787.             if (o && s + 2 > t)
  788.                 fmt_write_ordinal(++s, 10);
  789.             else
  790.                 fmt_write_numeral(++s, 10);
  791.             return(TRUE);
  792.         } else {
  793.             if (o && s + 1 > t)
  794.                 fmt_write_ordinal(s, 20);
  795.             else
  796.                 fmt_write_numeral(s, 20);
  797.             s++;
  798.             if (fmt_tempstr(s) > '0') {
  799.                 writec_stream('-', fmt_stream);
  800.                 if (o && s + 1 > t)
  801.                     fmt_write_ordinal(s, 0);
  802.                 else
  803.                     fmt_write_numeral(s, 0);
  804.             }
  805.             return(TRUE);
  806.         }
  807.     }
  808.     if (i == 2)
  809.         s++;
  810.     if (fmt_tempstr(s) > '0') {
  811.         if (b)
  812.             writec_stream(' ', fmt_stream);
  813.         if (o && s + 1 > t)
  814.             fmt_write_ordinal(s, 0);
  815.         else
  816.             fmt_write_numeral(s, 0);
  817.         return(TRUE);
  818.     }
  819.     return(b);
  820. }
  821.     
  822. fmt_write_numeral(s, i)
  823. int s, i;
  824. {
  825.     writestr_stream(fmt_numeral[fmt_tempstr(s) - '0' + i], fmt_stream);
  826. }
  827.  
  828. fmt_write_ordinal(s, i)
  829. int s, i;
  830. {
  831.     writestr_stream(fmt_ordinal[fmt_tempstr(s) - '0' + i], fmt_stream);
  832. }
  833.  
  834. fmt_roman(i, one, five, ten, colon)
  835. {
  836.     int j;
  837.  
  838.     if (i == 0)
  839.         return;
  840.     if (!colon && i < 4 || colon && i < 5)
  841.         for (j = 0;  j < i;  j++)
  842.             writec_stream(one, fmt_stream);
  843.     else if (!colon && i == 4) {
  844.         writec_stream(one, fmt_stream);
  845.         writec_stream(five, fmt_stream);
  846.     } else if (!colon && i < 9 || colon) {
  847.         writec_stream(five, fmt_stream);
  848.         for (j = 5;  j < i;  j++)
  849.             writec_stream(one, fmt_stream);
  850.     } else if (!colon && i == 9) {
  851.         writec_stream(one, fmt_stream);
  852.         writec_stream(ten, fmt_stream);
  853.     }
  854. }
  855.  
  856. fmt_plural(colon, atsign)
  857. {
  858.     fmt_max_param(0);
  859.     if (colon) {
  860.         if (fmt_index == 0)
  861.             fmt_error("can't back up");
  862.         --fmt_index;
  863.     }
  864.     if (eql(fmt_advance(), make_fixnum(1)))
  865.         if (atsign)
  866.             writec_stream('y', fmt_stream);
  867.         else
  868.             ;
  869.     else
  870.         if (atsign)
  871.             writestr_stream("ies", fmt_stream);
  872.         else
  873.             writec_stream('s', fmt_stream);
  874. }
  875.  
  876. fmt_character(colon, atsign)
  877. {
  878.     object x;
  879.     int i;
  880.  
  881.     fmt_max_param(0);
  882.     fmt_temporary_string->st.st_fillp = 0;
  883.     fmt_temporary_stream->sm.sm_int0 = 0;
  884.     fmt_temporary_stream->sm.sm_int1 = 0;
  885.     x = fmt_advance();
  886.     check_type_character(&x);
  887.     prin1(x, fmt_temporary_stream);
  888.     if (!colon && atsign)
  889.         i = 0;
  890.     else
  891.         i = 2;
  892.     for (;  i < fmt_temporary_string->st.st_fillp;  i++)
  893.         writec_stream(fmt_tempstr(i), fmt_stream);
  894. }
  895.  
  896. fmt_fix_float(colon, atsign)
  897. {
  898.     int w, d, k, overflowchar, padchar;
  899.     double f;
  900.     int sign;
  901.     char buff[256], *b, buff1[256];
  902.     int exp;
  903.     int i, j;
  904.     object x;
  905.     int n, m;
  906.     vs_mark;
  907.  
  908.     b = buff1 + 1;
  909.  
  910.     fmt_not_colon(colon);
  911.     fmt_max_param(5);
  912.     fmt_set_param(0, &w, INT, 0);
  913.     if (w < 0)
  914.         fmt_error("illegal width");
  915.     fmt_set_param(0, &w, INT, -1);
  916.     fmt_set_param(1, &d, INT, 0);
  917.     if (d < 0)
  918.         fmt_error("illegal number of digits");
  919.     fmt_set_param(1, &d, INT, -1);
  920.     fmt_set_param(2, &k, INT, 0);
  921.     fmt_set_param(3, &overflowchar, CHAR, -1);
  922.     fmt_set_param(4, &padchar, CHAR, ' ');
  923.  
  924.     x = fmt_advance();
  925.     if (type_of(x) == t_fixnum ||
  926.         type_of(x) == t_bignum ||
  927.         type_of(x) == t_ratio) {
  928.         x = make_shortfloat((shortfloat)number_to_double(x));
  929.         vs_push(x);
  930.     }
  931.     if (type_of(x) == t_complex) {
  932.         if (w < 0)
  933.             prin1(x, fmt_stream);
  934.         else {
  935.             fmt_nparam = 1;
  936.             --fmt_index;
  937.             fmt_decimal(colon, atsign);
  938.         }
  939.         vs_reset;
  940.         return;
  941.     }
  942.     if (type_of(x) == t_longfloat)
  943.         n = 16;
  944.     else
  945.         n = 7;
  946.     f = number_to_double(x);
  947.     edit_double(n, f, &sign, buff, &exp);
  948.     if (exp + k > 100 || exp + k < -100 || d > 100) {
  949.         prin1(x, fmt_stream);
  950.         vs_reset;
  951.         return;
  952.     }
  953.     if (d >= 0)
  954.         m = d + exp + k + 1;
  955.     else if (w >= 0) {
  956.         if (exp + k >= 0)
  957.             m = w - 1;
  958.         else
  959.             m = w + exp + k - 2;
  960.         if (sign < 0 || atsign)
  961.             --m;
  962.         if (m == 0)
  963.             m = 1;
  964.     } else
  965.         m = n;
  966.     if (m <= 0) {
  967.         if (m == 0 && buff[0] >= '5') {
  968.             exp++;
  969.             n = m = 1;
  970.             buff[0] = '1';
  971.         } else
  972.             n = m = 0;
  973.     } else if (m < n) {
  974.         n = m;
  975.         edit_double(n, f, &sign, buff, &exp);
  976.     }
  977.     while (n >= 0)
  978.         if (buff[n - 1] == '0')
  979.             --n;
  980.         else
  981.             break;
  982.     exp += k;
  983.     j = 0;
  984.     if (exp >= 0) {
  985.         for (i = 0;  i <= exp;  i++)
  986.             b[j++] = i < n ? buff[i] : '0';
  987.         b[j++] = '.';
  988.         if (d >= 0)
  989.             for (m = i + d;  i < m;  i++)
  990.                 b[j++] = i < n ? buff[i] : '0';
  991.         else
  992.             for (;  i < n;  i++)
  993.                 b[j++] = buff[i];
  994.     } else {
  995.         b[j++] = '.';
  996.         if (d >= 0) {
  997.             for (i = 0;  i < (-exp) - 1 && i < d;  i++)
  998.                 b[j++] = '0';
  999.             for (m = d - i, i = 0;  i < m;  i++)
  1000.                 b[j++] = i < n ? buff[i] : '0';
  1001.         } else if (n > 0) {
  1002.             for (i = 0;  i < (-exp) - 1;  i++)
  1003.                 b[j++] = '0';
  1004.             for (i = 0;  i < n;  i++)
  1005.                 b[j++] = buff[i];
  1006.         }
  1007.     }
  1008.     b[j] = '\0';
  1009.     if (w >= 0) {
  1010.         if (sign < 0 || atsign)
  1011.             --w;
  1012.         if (j > w && overflowchar >= 0)
  1013.             goto OVER;
  1014.         if (j < w && b[j-1] == '.' && d) {
  1015.             b[j++] = '0';
  1016.             b[j] = '\0';
  1017.         }
  1018.         if (j < w && b[0] == '.') {
  1019.             *--b = '0';
  1020.             j++;
  1021.         }
  1022.         for (i = j;  i < w;  i++)
  1023.             writec_stream(padchar, fmt_stream);
  1024.     } else {
  1025.         if (b[0] == '.') {
  1026.             *--b = '0';
  1027.             j++;
  1028.         }
  1029.         if (d < 0 && b[j-1] == '.') {
  1030.             b[j++] = '0';
  1031.             b[j] = '\0';
  1032.         }
  1033.     }
  1034.     if (sign < 0)
  1035.         writec_stream('-', fmt_stream);
  1036.     else if (atsign)
  1037.         writec_stream('+', fmt_stream);
  1038.     writestr_stream(b, fmt_stream);
  1039.     vs_reset;
  1040.     return;
  1041.  
  1042. OVER:
  1043.     fmt_set_param(0, &w, INT, 0);
  1044.     for (i = 0;  i < w;  i++)
  1045.         writec_stream(overflowchar, fmt_stream);
  1046.     vs_reset;
  1047.     return;
  1048. }
  1049.  
  1050. int
  1051. fmt_exponent_length(e)
  1052. {
  1053.     int i;
  1054.  
  1055.     if (e == 0)
  1056.         return(1);
  1057.     if (e < 0)
  1058.         e = -e;
  1059.     for (i = 0;  e > 0;  i++, e /= 10)
  1060.         ;
  1061.     return(i);
  1062. }
  1063.  
  1064. fmt_exponent(e)
  1065. {
  1066.     if (e == 0) {
  1067.         writec_stream('0', fmt_stream);
  1068.         return;
  1069.     }
  1070.     if (e < 0)
  1071.         e = -e;
  1072.     fmt_exponent1(e);
  1073. }
  1074.     
  1075. fmt_exponent1(e)
  1076. {
  1077.     if (e == 0)
  1078.         return;
  1079.     fmt_exponent1(e/10);
  1080.     writec_stream('0' + e%10, fmt_stream);
  1081. }
  1082.  
  1083. fmt_exponential_float(colon, atsign)
  1084. {
  1085.     int w, d, e, k, overflowchar, padchar, exponentchar;
  1086.     double f;
  1087.     int sign;
  1088.     char buff[256], *b, buff1[256];
  1089.     int exp;
  1090.     int i, j;
  1091.     object x, y;
  1092.     int n, m;
  1093.     enum type t;
  1094.     vs_mark;
  1095.  
  1096.     b = buff1 + 1;
  1097.  
  1098.     fmt_not_colon(colon);
  1099.     fmt_max_param(7);
  1100.     fmt_set_param(0, &w, INT, 0);
  1101.     if (w < 0)
  1102.         fmt_error("illegal width");
  1103.     fmt_set_param(0, &w, INT, -1);
  1104.     fmt_set_param(1, &d, INT, 0);
  1105.     if (d < 0)
  1106.         fmt_error("illegal number of digits");
  1107.     fmt_set_param(1, &d, INT, -1);
  1108.     fmt_set_param(2, &e, INT, 0);
  1109.     if (e < 0)
  1110.         fmt_error("illegal number of digits in exponent");
  1111.     fmt_set_param(2, &e, INT, -1);
  1112.     fmt_set_param(3, &k, INT, 1);
  1113.     fmt_set_param(4, &overflowchar, CHAR, -1);
  1114.     fmt_set_param(5, &padchar, CHAR, ' ');
  1115.     fmt_set_param(6, &exponentchar, CHAR, -1);
  1116.  
  1117.     x = fmt_advance();
  1118.     if (type_of(x) == t_fixnum ||
  1119.         type_of(x) == t_bignum ||
  1120.         type_of(x) == t_ratio) {
  1121.         x = make_shortfloat((shortfloat)number_to_double(x));
  1122.         vs_push(x);
  1123.     }
  1124.     if (type_of(x) == t_complex) {
  1125.         if (w < 0)
  1126.             prin1(x, fmt_stream);
  1127.         else {
  1128.             fmt_nparam = 1;
  1129.             --fmt_index;
  1130.             fmt_decimal(colon, atsign);
  1131.         }
  1132.         vs_reset;
  1133.         return;
  1134.     }
  1135.     if (type_of(x) == t_longfloat)
  1136.         n = 16;
  1137.     else
  1138.         n = 7;
  1139.     f = number_to_double(x);
  1140.     edit_double(n, f, &sign, buff, &exp);
  1141.     if (d >= 0) {
  1142.         if (k > 0) {
  1143.             if (!(k < d + 2))
  1144.                 fmt_error("illegal scale factor");
  1145.             m = d + 1;
  1146.         } else {
  1147.             if (!(k > -d))
  1148.                 fmt_error("illegal scale factor");
  1149.             m = d + k;
  1150.         }
  1151.     } else if (w >= 0) {
  1152.         if (k > 0)
  1153.             m = w - 1;
  1154.         else
  1155.             m = w + k - 1;
  1156.         if (sign < 0 || atsign)
  1157.             --m;
  1158.         if (e >= 0)
  1159.             m -= e + 2;
  1160.         else
  1161.             m -= fmt_exponent_length(e - k + 1) + 2;
  1162.     } else
  1163.         m = n;
  1164.     if (m <= 0) {
  1165.         if (m == 0 && buff[0] >= '5') {
  1166.             exp++;
  1167.             n = m = 1;
  1168.             buff[0] = '1';
  1169.         } else
  1170.             n = m = 0;
  1171.     } else if (m < n) {
  1172.         n = m;
  1173.         edit_double(n, f, &sign, buff, &exp);
  1174.     }
  1175.     while (n >= 0)
  1176.         if (buff[n - 1] == '0')
  1177.             --n;
  1178.         else
  1179.             break;
  1180.     exp = exp - k + 1;
  1181.     j = 0;
  1182.     if (k > 0) {
  1183.         for (i = 0;  i < k;  i++)
  1184.             b[j++] = i < n ? buff[i] : '0';
  1185.         b[j++] = '.';
  1186.         if (d >= 0)
  1187.             for (m = i + (d - k + 1);  i < m;  i++)
  1188.                 b[j++] = i < n ? buff[i] : '0';
  1189.         else
  1190.             for (;  i < n;  i++)
  1191.                 b[j++] = buff[i];
  1192.     } else {
  1193.         b[j++] = '.';
  1194.         if (d >= 0) {
  1195.             for (i = 0;  i < -k && i < d;  i++)
  1196.                 b[j++] = '0';
  1197.             for (m = d - i, i = 0;  i < m;  i++)
  1198.                 b[j++] = i < n ? buff[i] : '0';
  1199.         } else if (n > 0) {
  1200.             for (i = 0;  i < -k;  i++)
  1201.                 b[j++] = '0';
  1202.             for (i = 0;  i < n;  i++)
  1203.                 b[j++] = buff[i];
  1204.         }
  1205.     }
  1206.     b[j] = '\0';
  1207.     if (w >= 0) {
  1208.         if (sign < 0 || atsign)
  1209.             --w;
  1210.         i = fmt_exponent_length(exp);
  1211.         if (e >= 0) {
  1212.             if (i > e) {
  1213.                 if (overflowchar >= 0)
  1214.                     goto OVER;
  1215.                 else
  1216.                     e = i;
  1217.             }
  1218.             w -= e + 2;
  1219.         } else
  1220.             w -= i + 2;
  1221.         if (j > w && overflowchar >= 0)
  1222.             goto OVER;
  1223.         if (j < w && b[j-1] == '.') {
  1224.             b[j++] = '0';
  1225.             b[j] = '\0';
  1226.         }
  1227.         if (j < w && b[0] == '.') {
  1228.             *--b = '0';
  1229.             j++;
  1230.         }
  1231.         for (i = j;  i < w;  i++)
  1232.             writec_stream(padchar, fmt_stream);
  1233.     } else {
  1234.         if (b[j-1] == '.') {
  1235.             b[j++] = '0';
  1236.             b[j] = '\0';
  1237.         }
  1238.         if (d < 0 && b[0] == '.') {
  1239.             *--b = '0';
  1240.             j++;
  1241.         }
  1242.     }
  1243.     if (sign < 0)
  1244.         writec_stream('-', fmt_stream);
  1245.     else if (atsign)
  1246.         writec_stream('+', fmt_stream);
  1247.     writestr_stream(b, fmt_stream);
  1248.     y = symbol_value(Vread_default_float_format);
  1249.     if (exponentchar < 0) {
  1250.         if (y == Slong_float || y == Sdouble_float)
  1251.             t = t_longfloat;
  1252.         else
  1253.             t = t_shortfloat;
  1254.         if (type_of(x) == t)
  1255.             exponentchar = 'E';
  1256.         else if (type_of(x) == t_shortfloat)
  1257.             exponentchar = 'S';
  1258.         else
  1259.             exponentchar = 'L';
  1260.     }
  1261.     writec_stream(exponentchar, fmt_stream);
  1262.     if (exp < 0)
  1263.         writec_stream('-', fmt_stream);
  1264.     else
  1265.         writec_stream('+', fmt_stream);
  1266.     if (e >= 0)
  1267.         for (i = e - fmt_exponent_length(exp);  i > 0;  --i)
  1268.             writec_stream('0', fmt_stream);
  1269.     fmt_exponent(exp);
  1270.     vs_reset;
  1271.     return;
  1272.  
  1273. OVER:
  1274.     fmt_set_param(0, &w, INT, -1);
  1275.     for (i = 0;  i < w;  i++)
  1276.         writec_stream(overflowchar, fmt_stream);
  1277.     vs_reset;
  1278.     return;
  1279. }
  1280.  
  1281. fmt_general_float(colon, atsign)
  1282. {
  1283.     int w, d, e, k, overflowchar, padchar, exponentchar;
  1284.     int sign, exp;
  1285.     char buff[256];
  1286.     object x;
  1287.     int n, ee, ww, q, dd;
  1288.     vs_mark;
  1289.  
  1290.     fmt_not_colon(colon);
  1291.     fmt_max_param(7);
  1292.     fmt_set_param(0, &w, INT, 0);
  1293.     if (w < 0)
  1294.         fmt_error("illegal width");
  1295.     fmt_set_param(0, &w, INT, -1);
  1296.     fmt_set_param(1, &d, INT, 0);
  1297.     if (d < 0)
  1298.         fmt_error("illegal number of digits");
  1299.     fmt_set_param(1, &d, INT, -1);
  1300.     fmt_set_param(2, &e, INT, 0);
  1301.     if (e < 0)
  1302.         fmt_error("illegal number of digits in exponent");
  1303.     fmt_set_param(2, &e, INT, -1);
  1304.     fmt_set_param(3, &k, INT, 1);
  1305.     fmt_set_param(4, &overflowchar, CHAR, -1);
  1306.     fmt_set_param(5, &padchar, CHAR, ' ');
  1307.     fmt_set_param(6, &exponentchar, CHAR, -1);
  1308.  
  1309.     x = fmt_advance();
  1310.     if (type_of(x) == t_complex) {
  1311.         if (w < 0)
  1312.             prin1(x, fmt_stream);
  1313.         else {
  1314.             fmt_nparam = 1;
  1315.             --fmt_index;
  1316.             fmt_decimal(colon, atsign);
  1317.         }
  1318.         vs_reset;
  1319.         return;
  1320.     }
  1321.     if (type_of(x) == t_longfloat)
  1322.         q = 16;
  1323.     else
  1324.         q = 7;
  1325.     edit_double(q, number_to_double(x), &sign, buff, &exp);
  1326.     n = exp + 1;
  1327.     while (q >= 0)
  1328.         if (buff[q - 1] == '0')
  1329.             --q;
  1330.         else
  1331.             break;
  1332.     if (e >= 0)
  1333.         ee = e + 2;
  1334.     else
  1335.         ee = 4;
  1336.     ww = w - ee;
  1337.     if (d < 0) {
  1338.         d = n < 7 ? n : 7;
  1339.         d = q > d ? q : d;
  1340.     }
  1341.     dd = d - n;
  1342.     if (0 <= dd && dd <= d) {
  1343.         fmt_nparam = 5;
  1344.         fmt_param[0].fmt_param_value = ww;
  1345.         fmt_param[1].fmt_param_value = dd;
  1346.         fmt_param[1].fmt_param_type = INT;
  1347.         fmt_param[2].fmt_param_type = NULL;
  1348.         fmt_param[3] = fmt_param[4];
  1349.         fmt_param[4] = fmt_param[5];
  1350.         --fmt_index;
  1351.         fmt_fix_float(colon, atsign);
  1352.         if (w >= 0)
  1353.             while (ww++ < w)
  1354.                 writec_stream(padchar, fmt_stream);
  1355.         vs_reset;
  1356.         return;
  1357.     }
  1358.     fmt_param[1].fmt_param_value = d;
  1359.     fmt_param[1].fmt_param_type = INT;
  1360.     --fmt_index;
  1361.     fmt_exponential_float(colon, atsign);
  1362.     vs_reset;
  1363. }
  1364.  
  1365. fmt_dollars_float(colon, atsign)
  1366. {
  1367.     int d, n, w, padchar;
  1368.     double f;
  1369.     int sign;
  1370.     char buff[256];
  1371.     int exp;
  1372.     int q, i;
  1373.     object x;
  1374.     vs_mark;
  1375.  
  1376.     fmt_max_param(4);
  1377.     fmt_set_param(0, &d, INT, 2);
  1378.     if (d < 0)
  1379.         fmt_error("illegal number of digits");
  1380.     fmt_set_param(1, &n, INT, 1);
  1381.     if (n < 0)
  1382.         fmt_error("illegal number of digits");
  1383.     fmt_set_param(2, &w, INT, 0);
  1384.     if (w < 0)
  1385.         fmt_error("illegal width");
  1386.     fmt_set_param(3, &padchar, CHAR, ' ');
  1387.     x = fmt_advance();
  1388.     if (type_of(x) == t_complex) {
  1389.         if (w < 0)
  1390.             prin1(x, fmt_stream);
  1391.         else {
  1392.             fmt_nparam = 1;
  1393.             fmt_param[0] = fmt_param[2];
  1394.             --fmt_index;
  1395.             fmt_decimal(colon, atsign);
  1396.         }
  1397.         vs_reset;
  1398.         return;
  1399.     }
  1400.     q = 7;
  1401.     if (type_of(x) == t_longfloat)
  1402.         q = 16;
  1403.     f = number_to_double(x);
  1404.     edit_double(q, f, &sign, buff, &exp);
  1405.     if ((q = exp + d + 1) > 0)
  1406.         edit_double(q, f, &sign, buff, &exp);
  1407.     exp++;
  1408.     if (w > 100 || exp > 100 || exp < -100) {
  1409.         fmt_nparam = 6;
  1410.         fmt_param[0] = fmt_param[2];
  1411.         fmt_param[1].fmt_param_value = d + n - 1;
  1412.         fmt_param[1].fmt_param_type = INT;
  1413.         fmt_param[2].fmt_param_type =
  1414.         fmt_param[3].fmt_param_type =
  1415.         fmt_param[4].fmt_param_type = NULL;
  1416.         fmt_param[5] = fmt_param[3];
  1417.         --fmt_index;
  1418.         fmt_exponential_float(colon, atsign);
  1419.     }
  1420.     if (exp > n)
  1421.         n = exp;
  1422.     if (sign < 0 || atsign)
  1423.         --w;
  1424.     if (colon) {
  1425.         if (sign < 0)
  1426.             writec_stream('-', fmt_stream);
  1427.         else if (atsign)
  1428.             writec_stream('+', fmt_stream);
  1429.         while (--w > n + d)
  1430.             writec_stream(padchar, fmt_stream);
  1431.     } else {
  1432.         while (--w > n + d)
  1433.             writec_stream(padchar, fmt_stream);
  1434.         if (sign < 0)
  1435.             writec_stream('-', fmt_stream);
  1436.         else if (atsign)
  1437.             writec_stream('+', fmt_stream);
  1438.     }
  1439.     for (i = n - exp;  i > 0;  --i)
  1440.         writec_stream('0', fmt_stream);
  1441.     for (i = 0;  i < exp;  i++)
  1442.         writec_stream((i < q ? buff[i] : '0'), fmt_stream);
  1443.     writec_stream('.', fmt_stream);
  1444.     for (d += i;  i < d;  i++)
  1445.         writec_stream((i < q ? buff[i] : '0'), fmt_stream);
  1446.     vs_reset;
  1447. }
  1448.  
  1449. fmt_percent(colon, atsign)
  1450. {
  1451.     int n, i;
  1452.  
  1453.     fmt_max_param(1);
  1454.     fmt_set_param(0, &n, INT, 1);
  1455.     fmt_not_colon(colon);
  1456.     fmt_not_atsign(atsign);
  1457.     while (n-- > 0) {
  1458.                 WRITEC_NEWLINE(fmt_stream);
  1459.         if (n == 0)
  1460.             for (i = fmt_indents;  i > 0;  --i)
  1461.                 writec_stream(' ', fmt_stream);
  1462.     }
  1463. }
  1464.  
  1465. fmt_ampersand(colon, atsign)
  1466. {
  1467.     int n;
  1468.  
  1469.     fmt_max_param(1);
  1470.     fmt_set_param(0, &n, INT, 1);
  1471.     fmt_not_colon(colon);
  1472.     fmt_not_atsign(atsign);
  1473.     if (n == 0)
  1474.         return;
  1475.     if (file_column(fmt_stream) != 0)
  1476.       WRITEC_NEWLINE(fmt_stream);
  1477.     while (--n > 0)
  1478.             WRITEC_NEWLINE(fmt_stream);
  1479.     fmt_indents = 0;
  1480. }
  1481.  
  1482. fmt_bar(colon, atsign)
  1483. {
  1484.     int n;
  1485.  
  1486.     fmt_max_param(1);
  1487.     fmt_set_param(0, &n, INT, 1);
  1488.     fmt_not_colon(colon);
  1489.     fmt_not_atsign(atsign);
  1490.     while (n-- > 0)
  1491.         writec_stream('\f', fmt_stream);
  1492. }
  1493.  
  1494. fmt_tilde(colon, atsign)
  1495. {
  1496.     int n;
  1497.  
  1498.     fmt_max_param(1);
  1499.     fmt_set_param(0, &n, INT, 1);
  1500.     fmt_not_colon(colon);
  1501.     fmt_not_atsign(atsign);
  1502.     while (n-- > 0)
  1503.         writec_stream('~', fmt_stream);
  1504. }
  1505.  
  1506. fmt_newline(colon, atsign)
  1507. {
  1508.     int c;
  1509.  
  1510.     fmt_max_param(0);
  1511.     fmt_not_colon_atsign(colon, atsign);
  1512.     if (atsign)
  1513.       WRITEC_NEWLINE(fmt_stream);
  1514.     while (ctl_index < ctl_end && isspace(ctl_string[ctl_index])) {
  1515.         if (colon)
  1516.             writec_stream(ctl_string[ctl_index], fmt_stream);
  1517.         ctl_index++;
  1518.     }
  1519. }
  1520.  
  1521. fmt_tabulate(colon, atsign)
  1522. {
  1523.     int colnum, colinc;
  1524.     int c, i;
  1525.     
  1526.     fmt_max_param(2);
  1527.     fmt_not_colon(colon);
  1528.     fmt_set_param(0, &colnum, INT, 1);
  1529.     fmt_set_param(1, &colinc, INT, 1);
  1530.     if (!atsign) {
  1531.         c = file_column(fmt_stream);
  1532.         if (c < 0) {
  1533.             writestr_stream("  ", fmt_stream);
  1534.             return;
  1535.         }
  1536.         if (c > colnum && colinc <= 0)
  1537.             return;
  1538.         while (c > colnum)
  1539.             colnum += colinc;
  1540.         for (i = colnum - c;  i > 0;  --i)
  1541.             writec_stream(' ', fmt_stream);
  1542.     } else {
  1543.         for (i = colnum;  i > 0;  --i)
  1544.             writec_stream(' ', fmt_stream);
  1545.         c = file_column(fmt_stream);
  1546.         if (c < 0 || colinc <= 0)
  1547.             return;
  1548.         colnum = 0;
  1549.         while (c > colnum)
  1550.             colnum += colinc;
  1551.         for (i = colnum - c;  i > 0;  --i)
  1552.             writec_stream(' ', fmt_stream);
  1553.     }
  1554. }
  1555.  
  1556. fmt_asterisk(colon, atsign)
  1557. {
  1558.     int n;
  1559.  
  1560.     fmt_max_param(1);
  1561.     fmt_not_colon_atsign(colon, atsign);
  1562.     if (atsign) {
  1563.         fmt_set_param(0, &n, INT, 0);
  1564.         if (n < 0 || n >= fmt_end)
  1565.             fmt_error("can't goto");
  1566.         fmt_index = n;
  1567.     } else if (colon) {
  1568.         fmt_set_param(0, &n, INT, 1);
  1569.         if (n > fmt_index)
  1570.             fmt_error("can't back up");
  1571.         fmt_index -= n;
  1572.     } else {
  1573.         fmt_set_param(0, &n, INT, 1);
  1574.         while (n-- > 0)
  1575.             fmt_advance();
  1576.     }
  1577. }    
  1578.  
  1579. fmt_indirection(colon, atsign)
  1580. {
  1581.     object s, l;
  1582.     fmt_old;
  1583.     jmp_buf fmt_jmp_buf0;
  1584.     int up_colon;
  1585.  
  1586.     fmt_max_param(0);
  1587.     fmt_not_colon(colon);
  1588.     s = fmt_advance();
  1589.     if (type_of(s) != t_string)
  1590.         fmt_error("control string expected");
  1591.     if (atsign) {
  1592.         fmt_save;
  1593.         fmt_jmp_buf = fmt_jmp_buf0;
  1594.         fmt_string = s;
  1595.         if (up_colon = setjmp(fmt_jmp_buf)) {
  1596.             if (--up_colon)
  1597.                 fmt_error("illegal ~:^");
  1598.         } else
  1599.             format(fmt_stream, 0, s->st.st_fillp);
  1600.         fmt_restore1;
  1601.     } else {
  1602.         l = fmt_advance();
  1603.         fmt_save;
  1604.         fmt_base = vs_top;
  1605.         fmt_index = 0;
  1606.         for (fmt_end = 0;  !endp(l);  fmt_end++, l = l->c.c_cdr)
  1607.             vs_check_push(l->c.c_car);
  1608.         fmt_jmp_buf = fmt_jmp_buf0;
  1609.         fmt_string = s;
  1610.         if (up_colon = setjmp(fmt_jmp_buf)) {
  1611.             if (--up_colon)
  1612.                 fmt_error("illegal ~:^");
  1613.         } else
  1614.             format(fmt_stream, 0, s->st.st_fillp);
  1615.         vs_top = fmt_base;
  1616.         fmt_restore;
  1617.     }
  1618. }
  1619.  
  1620. fmt_case(colon, atsign)
  1621. {
  1622.     VOL object x;
  1623.     VOL int i, j;
  1624.     fmt_old;
  1625.     jmp_buf fmt_jmp_buf0;
  1626.     int up_colon;
  1627.     bool b;
  1628.  
  1629.     x = make_string_output_stream(64);
  1630.     vs_push(x);
  1631.     i = ctl_index;
  1632.     j = fmt_skip();
  1633.     if (ctl_string[--j] != ')' || ctl_string[--j] != '~')
  1634.         fmt_error("~) expected");
  1635.     fmt_save;
  1636.     fmt_jmp_buf = fmt_jmp_buf0;
  1637.     if (up_colon = setjmp(fmt_jmp_buf))
  1638.         ;
  1639.     else
  1640.         format(x, ctl_origin + i, j - i);
  1641.     fmt_restore1;
  1642.     x = x->sm.sm_object0;
  1643.     if (!colon && !atsign)
  1644.         for (i = 0;  i < x->st.st_fillp;  i++) {
  1645.             if (isUpper(j = x->st.st_self[i]))
  1646.                 j += 'a' - 'A';
  1647.             writec_stream(j, fmt_stream);
  1648.         }
  1649.     else if (colon && !atsign)
  1650.         for (b = TRUE, i = 0;  i < x->st.st_fillp;  i++) {
  1651.             if (isLower(j = x->st.st_self[i])) {
  1652.                 if (b)
  1653.                     j -= 'a' - 'A';
  1654.                 b = FALSE;
  1655.             } else if (isUpper(j)) {
  1656.                 if (!b)
  1657.                     j += 'a' - 'A';
  1658.                 b = FALSE;
  1659.             } else if (!isDigit(j))
  1660.                 b = TRUE;
  1661.             writec_stream(j, fmt_stream);
  1662.         }
  1663.     else if (!colon && atsign)
  1664.         for (b = TRUE, i = 0;  i < x->st.st_fillp;  i++) {
  1665.             if (isLower(j = x->st.st_self[i])) {
  1666.                 if (b)
  1667.                     j -= 'a' - 'A';
  1668.                 b = FALSE;
  1669.             } else if (isUpper(j)) {
  1670.                 if (!b)
  1671.                     j += 'a' - 'A';
  1672.                 b = FALSE;
  1673.             }
  1674.             writec_stream(j, fmt_stream);
  1675.         }
  1676.     else
  1677.         for (i = 0;  i < x->st.st_fillp;  i++) {
  1678.             if (isLower(j = x->st.st_self[i]))
  1679.                 j -= 'a' - 'A';
  1680.             writec_stream(j, fmt_stream);
  1681.         }
  1682.     vs_pop;
  1683.     if (up_colon)
  1684.         longjmp(fmt_jmp_buf, up_colon);
  1685. }
  1686.  
  1687. fmt_conditional(colon, atsign)
  1688. {
  1689.     int i, j, k;
  1690.     object x;
  1691.     int n;
  1692.     bool done;
  1693.     fmt_old;
  1694.  
  1695.     fmt_not_colon_atsign(colon, atsign);
  1696.     if (colon) {
  1697.         fmt_max_param(0);
  1698.         i = ctl_index;
  1699.         j = fmt_skip();
  1700.         if (ctl_string[--j] != ';' || ctl_string[--j] != '~')
  1701.             fmt_error("~; expected");
  1702.         k = fmt_skip();
  1703.         if (ctl_string[--k] != ']' || ctl_string[--k] != '~')
  1704.             fmt_error("~] expected");
  1705.         if (fmt_advance() == Cnil) {
  1706.             fmt_save;
  1707.             format(fmt_stream, ctl_origin + i, j - i);
  1708.             fmt_restore1;
  1709.         } else {
  1710.             fmt_save;
  1711.             format(fmt_stream, ctl_origin + j + 2, k - (j + 2));
  1712.             fmt_restore1;
  1713.         }
  1714.     } else if (atsign) {
  1715.         i = ctl_index;
  1716.         j = fmt_skip();
  1717.         if (ctl_string[--j] != ']' || ctl_string[--j] != '~')
  1718.             fmt_error("~] expected");
  1719.         if (fmt_advance() == Cnil)
  1720.             ;
  1721.         else {
  1722.             --fmt_index;
  1723.             fmt_save;
  1724.             format(fmt_stream, ctl_origin + i, j - i);
  1725.             fmt_restore1;
  1726.         }
  1727.     } else {
  1728.         fmt_max_param(1);
  1729.         if (fmt_nparam == 0) {
  1730.             x = fmt_advance();
  1731.             if (type_of(x) != t_fixnum)
  1732.                 fmt_error("illegal argument for conditional");
  1733.             n = fix(x);
  1734.         } else
  1735.             fmt_set_param(0, &n, INT, 0);
  1736.         i = ctl_index;
  1737.         for (done = FALSE;;  --n) {
  1738.             j = fmt_skip();
  1739.             for (k = j;  ctl_string[--k] != '~';)
  1740.                 ;
  1741.             if (n == 0) {
  1742.                 fmt_save;
  1743.                 format(fmt_stream, ctl_origin + i, k - i);
  1744.                 fmt_restore1;
  1745.                 done = TRUE;
  1746.             }
  1747.             i = j;
  1748.             if (ctl_string[--j] == ']') {
  1749.                 if (ctl_string[--j] != '~')
  1750.                     fmt_error("~] expected");
  1751.                 return;
  1752.             }
  1753.             if (ctl_string[j] == ';') {
  1754.                 if (ctl_string[--j] == '~')
  1755.                     continue;
  1756.                 if (ctl_string[j] == ':')
  1757.                     goto ELSE;
  1758.             }
  1759.             fmt_error("~; or ~] expected");
  1760.         }
  1761.     ELSE:
  1762.         if (ctl_string[--j] != '~')
  1763.             fmt_error("~:; expected");
  1764.         j = fmt_skip();
  1765.         if (ctl_string[--j] != ']' || ctl_string[--j] != '~')
  1766.             fmt_error("~] expected");
  1767.         if (!done) {
  1768.             fmt_save;
  1769.             format(fmt_stream, ctl_origin + i, j - i);
  1770.             fmt_restore1;
  1771.         }
  1772.     }
  1773. }    
  1774.  
  1775. fmt_iteration(colon, atsign)
  1776. {
  1777.     int i,n;
  1778.     VOL int j;
  1779.     int o;
  1780.     bool colon_close = FALSE;
  1781.     object l;
  1782.     VOL object l0;
  1783.     fmt_old;
  1784.     jmp_buf fmt_jmp_buf0;
  1785.     int up_colon;
  1786.  
  1787.     fmt_max_param(1);
  1788.     fmt_set_param(0, &n, INT, 1000000);
  1789.     i = ctl_index;
  1790.     j = fmt_skip();
  1791.     if (ctl_string[--j] != '}')
  1792.         fmt_error("~} expected");
  1793.     if (ctl_string[--j] == ':') {
  1794.         colon_close = TRUE;
  1795.         --j;
  1796.     }
  1797.     if (ctl_string[j] != '~')
  1798.         fmt_error("syntax error");
  1799.     o = ctl_origin;
  1800.     if (!colon && !atsign) {
  1801.         l = fmt_advance();
  1802.         fmt_save;
  1803.         fmt_base = vs_top;
  1804.         fmt_index = 0;
  1805.         for (fmt_end = 0;  !endp(l);  fmt_end++, l = l->c.c_cdr)
  1806.             vs_check_push(l->c.c_car);
  1807.         fmt_jmp_buf = fmt_jmp_buf0;
  1808.         if (colon_close)
  1809.             goto L1;
  1810.         while (fmt_index < fmt_end) {
  1811.         L1:
  1812.             if (n-- <= 0)
  1813.                 break;
  1814.             if (up_colon = setjmp(fmt_jmp_buf)) {
  1815.                 if (--up_colon)
  1816.                     fmt_error("illegal ~:^");
  1817.                 break;
  1818.             }
  1819.             format(fmt_stream, o + i, j - i);
  1820.         }
  1821.         vs_top = fmt_base;
  1822.         fmt_restore;
  1823.     } else if (colon && !atsign) {
  1824.         l0 = fmt_advance();
  1825.         fmt_save;
  1826.         fmt_base = vs_top;
  1827.         fmt_jmp_buf = fmt_jmp_buf0;
  1828.         if (colon_close)
  1829.             goto L2;
  1830.         while (!endp(l0)) {
  1831.         L2:
  1832.             if (n-- <= 0)
  1833.                 break;
  1834.             l = l0->c.c_car;
  1835.             l0 = l0->c.c_cdr;
  1836.             fmt_index = 0;
  1837.             for (fmt_end = 0; !endp(l); fmt_end++, l = l->c.c_cdr)
  1838.                 vs_check_push(l->c.c_car);
  1839.             if (up_colon = setjmp(fmt_jmp_buf)) {
  1840.                 vs_top = fmt_base;
  1841.                 if (--up_colon)
  1842.                     break;
  1843.                 else
  1844.                     continue;
  1845.             }
  1846.             format(fmt_stream, o + i, j - i);
  1847.             vs_top = fmt_base;
  1848.         }
  1849.         fmt_restore;
  1850.     } else if (!colon && atsign) {
  1851.         fmt_save;
  1852.         fmt_jmp_buf = fmt_jmp_buf0;
  1853.         if (colon_close)
  1854.             goto L3;
  1855.         while (fmt_index < fmt_end) {
  1856.         L3:
  1857.             if (n-- <= 0)
  1858.                 break;
  1859.             if (up_colon = setjmp(fmt_jmp_buf)) {
  1860.                 if (--up_colon)
  1861.                     fmt_error("illegal ~:^");
  1862.                 break;
  1863.             }
  1864.             format(fmt_stream, o + i, j - i);
  1865.         }
  1866.         fmt_restore1;
  1867.     } else if (colon && atsign) {
  1868.         if (colon_close)
  1869.             goto L4;
  1870.         while (fmt_index < fmt_end) {
  1871.         L4:
  1872.             if (n-- <= 0)
  1873.                 break;
  1874.             l = fmt_advance();
  1875.             fmt_save;
  1876.             fmt_base = vs_top;
  1877.             fmt_index = 0;
  1878.             for (fmt_end = 0; !endp(l); fmt_end++, l = l->c.c_cdr)
  1879.                 vs_check_push(l->c.c_car);
  1880.             fmt_jmp_buf = fmt_jmp_buf0;
  1881.             if (up_colon = setjmp(fmt_jmp_buf)) {
  1882.                 vs_top = fmt_base;
  1883.                 fmt_restore;
  1884.                 if (--up_colon)
  1885.                     break;
  1886.                 else
  1887.                     continue;
  1888.             }
  1889.             format(fmt_stream, o + i, j - i);
  1890.             vs_top = fmt_base;
  1891.             fmt_restore;
  1892.         }
  1893.     }
  1894. }
  1895.  
  1896. #define FORMAT_DIRECTIVE_LIMIT 100
  1897.  
  1898. fmt_justification(colon, atsign)
  1899. {
  1900.     int mincol, colinc, minpad, padchar;
  1901.     object fields[FORMAT_DIRECTIVE_LIMIT];
  1902.     fmt_old;
  1903.     jmp_buf fmt_jmp_buf0;
  1904.     VOL int i,j,n,j0;
  1905.     int k,l,m,l0;
  1906.     int up_colon;
  1907.     VOL int special = 0;
  1908.     int spare_spaces, line_length;
  1909.     vs_mark;
  1910.  
  1911.     fmt_max_param(4);
  1912.     fmt_set_param(0, &mincol, INT, 0);
  1913.     fmt_set_param(1, &colinc, INT, 1);
  1914.     fmt_set_param(2, &minpad, INT, 0);
  1915.     fmt_set_param(3, &padchar, CHAR, ' ');
  1916.  
  1917.     n = 0;
  1918.     for (;;) {
  1919.         if (n >= FORMAT_DIRECTIVE_LIMIT)
  1920.             fmt_error("too many fields");
  1921.         i = ctl_index;
  1922.         j0 = j = fmt_skip();
  1923.         while (ctl_string[--j] != '~')
  1924.             ;
  1925.         fields[n] = make_string_output_stream(64);
  1926.         vs_push(fields[n]);
  1927.         fmt_save;
  1928.         fmt_jmp_buf = fmt_jmp_buf0;
  1929.         if (up_colon = setjmp(fmt_jmp_buf)) {
  1930.             --n;
  1931.             if (--up_colon)
  1932.                 fmt_error("illegal ~:^");
  1933.             fmt_restore1;
  1934.             while (ctl_string[--j0] != '>')
  1935.                 j0 = fmt_skip();
  1936.             if (ctl_string[--j0] != '~')
  1937.                 fmt_error("~> expected");
  1938.             break;
  1939.         }
  1940.         format(fields[n++], ctl_origin + i, j - i);
  1941.         fmt_restore1;
  1942.         if (ctl_string[--j0] == '>') {
  1943.             if (ctl_string[--j0] != '~')
  1944.                 fmt_error("~> expected");
  1945.             break;
  1946.         } else if (ctl_string[j0] != ';')
  1947.             fmt_error("~; expected");
  1948.         else if (ctl_string[--j0] == ':') {
  1949.             if (n != 1)
  1950.                 fmt_error("illegal ~:;");
  1951.             special = 1;
  1952.             for (j = j0;  ctl_string[j] != '~';  --j)
  1953.                 ;
  1954.             fmt_save;
  1955.             format(fmt_stream, ctl_origin + j, j0 - j + 2);
  1956.             fmt_restore1;
  1957.             spare_spaces = fmt_spare_spaces;
  1958.             line_length = fmt_line_length;
  1959.         } else if (ctl_string[j0] != '~')
  1960.             fmt_error("~; expected");
  1961.     }
  1962.     for (i = special, l = 0;  i < n;  i++)
  1963.         l += fields[i]->sm.sm_object0->st.st_fillp;
  1964.     m = n - 1 - special;
  1965.     if (m <= 0 && !colon && !atsign) {
  1966.         m = 0;
  1967.         colon = TRUE;
  1968.     }
  1969.     if (colon)
  1970.         m++;
  1971.     if (atsign)
  1972.         m++;
  1973.     l0 = l;
  1974.     l += minpad * m;
  1975.     for (k = 0;  mincol + k * colinc < l;  k++)
  1976.         ;
  1977.     l = mincol + k * colinc;
  1978.     if (special != 0 &&
  1979.         file_column(fmt_stream) + l + spare_spaces >= line_length)
  1980.         princ(fields[0]->sm.sm_object0, fmt_stream);
  1981.     l -= l0;
  1982.     for (i = special;  i < n;  i++) {
  1983.         if (m > 0 && (i > 0 || colon))
  1984.             for (j = l / m, l -= j, --m;  j > 0;  --j)
  1985.                 writec_stream(padchar, fmt_stream);
  1986.         princ(fields[i]->sm.sm_object0, fmt_stream);
  1987.     }
  1988.     if (atsign)
  1989.         for (j = l;  j > 0;  --j)
  1990.             writec_stream(padchar, fmt_stream);
  1991.     vs_reset;
  1992. }
  1993.  
  1994.  
  1995. fmt_up_and_out(colon, atsign)
  1996. {
  1997.     int i, j, k;
  1998.  
  1999.     fmt_max_param(3);
  2000.     fmt_not_atsign(atsign);
  2001.     if (fmt_nparam == 0) {
  2002.         if (fmt_index >= fmt_end)
  2003.             longjmp(fmt_jmp_buf, ++colon);
  2004.     } else if (fmt_nparam == 1) {
  2005.         fmt_set_param(0, &i, INT, 0);
  2006.         if (i == 0)
  2007.             longjmp(fmt_jmp_buf, ++colon);
  2008.     } else if (fmt_nparam == 2) {
  2009.         fmt_set_param(0, &i, INT, 0);
  2010.         fmt_set_param(1, &j, INT, 0);
  2011.         if (i == j)
  2012.             longjmp(fmt_jmp_buf, ++colon);
  2013.     } else {
  2014.         fmt_set_param(0, &i, INT, 0);
  2015.         fmt_set_param(1, &j, INT, 0);
  2016.         fmt_set_param(2, &k, INT, 0);
  2017.         if (i <= j && j <= k)
  2018.             longjmp(fmt_jmp_buf, ++colon);
  2019.     }
  2020. }
  2021.  
  2022.  
  2023. fmt_semicolon(colon, atsign)
  2024. {
  2025.     fmt_not_atsign(atsign);
  2026.     if (!colon)
  2027.         fmt_error("~:; expected");
  2028.     fmt_max_param(2);
  2029.     fmt_set_param(0, &fmt_spare_spaces, INT, 0);
  2030.     fmt_set_param(1, &fmt_line_length, INT, 72);
  2031. }
  2032.  
  2033.  
  2034. object 
  2035. LVformat(strm, control, va_alist)
  2036.      object strm;
  2037.      object control;
  2038.      va_dcl
  2039. {       va_list ap; 
  2040.         VOL int nargs= VFUN_NARGS;
  2041.     VOL object x = OBJNULL;
  2042.     jmp_buf fmt_jmp_buf0;
  2043.     bool colon, e;
  2044.     fmt_old;
  2045.     nargs=nargs-2;
  2046.     if (nargs < 0)
  2047.         too_few_arguments();
  2048.     if (strm == Cnil) {
  2049.         strm = make_string_output_stream(64);
  2050.         x = strm->sm.sm_object0;
  2051.     } else if (strm == Ct)
  2052.         strm = symbol_value(Vstandard_output);
  2053.     else if (type_of(strm) == t_string) {
  2054.         x = strm;
  2055.         if (!x->st.st_hasfillp)
  2056.           FEerror("The string ~S doesn't have a fill-pointer.", 1, x);
  2057.         strm = make_string_output_stream(0);
  2058.         strm->sm.sm_object0 = x;
  2059.     } else
  2060.         check_type_stream(&strm);
  2061.     check_type_string(&control);
  2062.     fmt_save;
  2063.     frs_push(FRS_PROTECT, Cnil);
  2064.     if (nlj_active) {
  2065.         e = TRUE;
  2066.         goto L;
  2067.     }
  2068.     
  2069.     va_start(ap);
  2070.     {object *l;
  2071.      COERCE_VA_LIST(l,ap,nargs);
  2072.     fmt_base = l;
  2073.     fmt_index = 0;
  2074.     fmt_end = nargs;
  2075.     fmt_jmp_buf = fmt_jmp_buf0;
  2076.     if (symbol_value(siVindent_formatted_output) != Cnil)
  2077.         fmt_indents = file_column(strm);
  2078.     else
  2079.         fmt_indents = 0;
  2080.     fmt_string = control;
  2081.     if (colon = setjmp(fmt_jmp_buf)) {
  2082.         if (--colon)
  2083.             fmt_error("illegal ~:^");
  2084.         vs_base = vs_top;
  2085.         if (x != OBJNULL)
  2086.             vs_push(x);
  2087.         else
  2088.             vs_push(Cnil);
  2089.         e = FALSE;
  2090.         goto L;
  2091.     }
  2092.     format(strm, 0, control->st.st_fillp);
  2093.     flush_stream(strm);
  2094.        }
  2095.     va_end(ap);
  2096.     e = FALSE;
  2097. L:
  2098.     frs_pop();
  2099.     fmt_restore;
  2100.     if (e) {
  2101.         nlj_active = FALSE;
  2102.         unwind(nlj_fr, nlj_tag);
  2103.     }
  2104.     return (x ==0 ? Cnil : x);  
  2105. }
  2106.  
  2107. object c_apply_n();
  2108.  
  2109. void
  2110. Lformat()
  2111. {object *b=vs_base;
  2112.  VFUN_NARGS = vs_top-vs_base;
  2113.  b[0]= c_apply_n(LVformat,vs_top-vs_base,vs_base);
  2114.  vs_top=((vs_base=b)+1);
  2115. }
  2116.  
  2117. fmt_error(s)
  2118. {
  2119.     vs_push(make_simple_string(s));
  2120.     vs_push(make_fixnum(&ctl_string[ctl_index] - fmt_string->st.st_self));
  2121.     FEerror("Format error: ~A.~%~V@TV~%\"~A\"~%",
  2122.         3, vs_top[-2], vs_top[-1], fmt_string);
  2123. }
  2124.  
  2125. init_format()
  2126. {
  2127.     fmt_temporary_stream = make_string_output_stream(64);
  2128.     enter_mark_origin(&fmt_temporary_stream);
  2129.     fmt_temporary_string = fmt_temporary_stream->sm.sm_object0;
  2130.  
  2131.     make_function("FORMAT", Lformat);
  2132.  
  2133.     siVindent_formatted_output
  2134.     = make_si_special("*INDENT-FORMATTED-OUTPUT*", Cnil);
  2135. }
  2136.